ccccccccccccccccccccccccccccccc
cc                           cc
cc  pmtexb.for Version 1.0   cc
cc                           cc
ccccccccccccccccccccccccccccccc
cc
cc  file pmtex.inc
cc
cc      common /all/ mult(5,200),iv,list(4,200),nnl(5),nv,ibar,
cc     *   ipl(5,200),ibm1(5,8),ibm2(5,8),nolev(5,200),ibmcnt(5),
cc     *   nodur(5,200),ncmid(5),jn,lenbar,iccount,nbars,itsofar(5),
cc     *   nib(5,15),nn(5),
cc     *   rest(5,200),beamon(5) ,lenbar0,lenbar1,firstline,
cc     *   slfac,musicsize,stemmax,stemmin,stemlen
cc      common /all/ acc(5,200),ul(5,8),hb(5,8),orn(5,200),
cc     *   fig(200),sepsym,s
cc      character*6 fig
cc      character*1 acc,ul,hb,orn,sepsym,s
cc      logical beamon,rest,firstline
cc
cccccccccccccccccccccccccccccc
      include 'pmtex.inc'
      logical loop,lastchar,figbass
      character*1  clef(5)
      character*80 line
      character*40 pathname
      character*24 autoline,basename,iname
      common /comfig/ ifigdrop(50),iline,figbass
      common /comget/ lastchar
      common /combeam/ lenbeam
      common /comtop / itopfacteur,ibotfacteur,interfacteur,
     *   isig,fracindent,imeter,mtrnum,mtrden,iwaskpt,widthpt,height
      common /comtop/ iname(5)
c
c  iccount: pointer in string from input file.  Just before calling getchar,
c          it points to the last character retrieved. 
c  nnl    : # of notes in a line (//)
c  itsofar: time in current line from start of line
c
      widthpt = 524
      iwaskpt = 3
      height = 770.
      slfac1 = 0.00569  
      stemmax = 8.2 
      stemmin = 3.9
      stemlen = 6.0
c  Platform-independent backslash
      s = char(92)
      open(12,file='pmtex.dat')
      read(12,'(a)')basename
      read(12,*)lbase
      read(12,*)itopfacteur,ibotfacteur,interfacteur,iauto
      open(10,file=basename(1:lbase)//'.inp')
      read(10,*)nv,noinst,mtrnum,mtrden,imeter,xmtrnum0,isig,
     *          lpp,nstaves,musicsize,fracindent
c
c imeter = 0 for fraction        noinst = 0  if several voices, 1 inst
c          2,3,4  single-digit            nv if separate inst's
c          5 for cut time
c          6 for common time
c
      do 6 iv = 1 , nv
        read(10,'(a24)')iname(iv)
6     continue
      read(10,'(a80)')line
      do 7 iv = 1 , nv
        clef(iv) = line(iv:iv)
7     continue
      read(10,'(a)')pathname
      lpath = index(pathname,' ')-1
      open(13,file='pmtex.fig')
      figbass = .false.
      read(13,*)ifig
      if (ifig .eq. 1) then
        figbass = .true.
        iline = 1
        ifigdrop(1) = 4
        open(14,file=pathname(1:lpath)//basename(1:lbase)//'.fig')
        write(14,'(a)')
     *    s//'def'//s//'fixdrop{'//s//'ifcase'//s//'sysno%'
      end if
      lastchar = .false.
c  Bar count offset
      ibcoff = 0
      if (xmtrnum0 .gt. 0.) ibcoff = -1
      open(11,file=pathname(1:lpath)//basename(1:lbase)//'.tex')
      sepsym = '|'
      if (noinst .gt. 1) sepsym = '&'
      call topfile(basename,lbase,nv,clef,noinst,musicsize,figbass)
      lenbeat = ifnodur(mtrden,'x')
      lenbar = mtrnum*lenbeat
      lenbar1 = mtrnum*lenbeat
      lenbar0 = xmtrnum0*lenbeat+.5
      if (lenbar0 .ne. 0) then
        write(11,'(a)')s//'advance'//s//'barno by -1'
        lenbar = lenbar0
      else
        lenbar = lenbar1
      end if
c### The following may need revision for different time sig's.
      if (mtrden .eq. 4) then
        lenbeam = 24
      else if (mtrden .eq. 8) then
        lenbeam = 36
      end if
      ibarcnt = 0
      iccount = 80
      do 1 iv = 1 , nv
        ncmid(iv) = ncmidf(clef(iv))
1     continue
c
c  Initialize for loop over lines
c
      firstline = .true.
30    loop = .true.
      nbars = 0
3     do 4 iv = 1 , nv
        itsofar(iv) = 0
        nnl(iv) = 0
        do 5 j = 1 , 200
          rest(iv,j) = .false.
          acc(iv,j) = 'x'
          orn(iv,j) = 'x'
          if (iv .eq. 1) fig(j) = 'x'
5       continue
4     continue 
      iv = 1
2     if (loop) then
c
c  Within this loop, nv voices are filled up for the duration of the line.
c  On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv)
c  nolev(nv,nnl(nv)),nodur(..),acc(..),rest(..).  nnl will later be
c  increased and things slid around as accidental skips are added.  
c
        call getnote(loop) 
        if (lastchar) go to 40
        go to 2
      end if
      firstline = .false.
      do 10 ibar = 1 , nbars
        ibarcnt = ibarcnt+1
        print*,'Now processing bar #',ibarcnt+ibcoff
        write(11,'(a5,i3)')'% bar',ibarcnt+ibcoff
        if (ibarcnt .gt. 1) then
          write(11,'(a6)')s//'barre'
          if (ibarcnt.eq.iauto .and. figbass) then
            write(14,'(a16,i2,a10)')
     *        s//'global'//s//'figdrop=',ifigdrop(iline),
     *        s//'relax'//s//'or%'
            iline = iline+1
            ifigdrop(iline) = 4
          end if
        end if
        if (ibarcnt .eq. iauto) then
          read(12,'(a24)')autoline
          read(autoline,'(7x,i2,2x,i2)')ielperbar,ibarperln
          slfac = slfac1*musicsize*ielperbar*ibarperln
          write(11,'(a24)')autoline
          read(12,*)iauto
        end if
        if (ibar .gt. 1) then
c
c  For bars after first, slide all stuff down to beginning of arrays
c
          do 11 iv = 1 , nv
            ioff = nib(iv,ibar-1)
            do 12 ip = 1 , nib(iv,ibar)-ioff
              nolev(iv,ip) = nolev(iv,ip+ioff)
              nodur(iv,ip) = nodur(iv,ip+ioff)
              acc(iv,ip) = acc(iv,ip+ioff)
              rest(iv,ip) = rest(iv,ip+ioff)
              orn(iv,ip) = orn(iv,ip+ioff)
              if (iv.eq.1) fig(ip) = fig(ip+ioff)
12          continue
11        continue
        end if
        call makeabar()
10    continue
      go to 30
40    close(12)
      close(13)
      close(10)
      close(11)
      if (figbass) then
        write(14,'(a16,i2,a10)')
     *        s//'global'//s//'figdrop=',ifigdrop(iline),
     *        s//'relax'//s//'fi}%'
        close(14)
      end if
      print*,'Writing ',pathname(1:lpath)//basename(1:lbase)//'.tex '
     *  //'and exiting'
      end
      subroutine getnote(loop)
      include 'pmtex.inc'
      common /comget/ lastchar
      character*80 line
      logical loop,lastchar
      character*1 char,oct,dot
1     call getchar(line,iccount,char)
      if (lastchar) return
      if (char .eq. ' ') then
        go to 1
      else if (char .eq. '%') then
        iccount = 80
        go to 1
      else if (ichar(char).ge.97 .and. ichar(char).le.103) then
c
c This is a note.  Increase note count, get octave & basic duration.
c
        nnl(iv) = nnl(iv)+1
        call getchar(line,iccount,oct)
        if (lastchar) return
        dot = 'x'
        if (oct .ne. ' ') then
          read(oct,'(i1)')ioct
          nolev(iv,nnl(iv)) = ifnolev(char,ioct)
          call getchar(line,iccount,char)
          if (lastchar) return
        else
c#### Get octave from previous one
          nolev(iv,nnl(iv)) = ifnolev(char,ioct)
          if (nolev(iv,nnl(iv)) .gt. nolev(iv,nnl(iv)-1)+3) then
            nolev(iv,nnl(iv)) = nolev(iv,nnl(iv))-7
          else if (nolev(iv,nnl(iv)) .lt. nolev(iv,nnl(iv)-1)-3) then
            nolev(iv,nnl(iv)) = nolev(iv,nnl(iv))+7
          end if
          char = ' '
        end if 
        if (char .eq. ' ') then
          nodur(iv,nnl(iv)) = nodur(iv,nnl(iv)-1)
          go to 4
        end if
        read(char,'(i1)')inodur
2       call getchar(line,iccount,char)
        if (lastchar) return
        if (char .ne. ' ') then
          if (char .eq. 'd') then
            dot = char
          else if (char .eq. '/') then
            continue
          else
c
c  Only other possibility is an accidental
c
            acc(iv,nnl(iv)) = char
          end if
          if (char .ne. '/') go to 2
        end if
        nodur(iv,nnl(iv)) = ifnodur(inodur,dot)
4       itsofar(iv) = itsofar(iv)+nodur(iv,nnl(iv))
        if (mod(itsofar(iv),lenbar) .eq. 0) then
          nbars = nbars+1
          nib(iv,nbars) = nnl(iv)
          if (lenbar .ne. lenbar1) then
c
c###  Just finished the pickup bar for this voice.
c
            lenbar = lenbar1
            itsofar(iv) = 0
          end if
        end if 
      else if (char .eq. 'o') then
c###             "o" symbol must come AFTER the affected note
        call getchar(line,iccount,orn(iv,nnl(iv))) 
        if (lastchar) return
      else if ((ichar(char).ge.49.and.ichar(char).le.57) .or.
     *    char.eq.'#' .or. char.eq.'-' .or. char.eq.'n'
     *    .or. char.eq.'_') then
c###            We have a figure.  Must come AFTER the note it goes under
        lfig = 1
        fig(nnl(iv)) = char
5       call getchar(line,iccount,char)
        if (lastchar) return
        if (char .ne. ' ') then
          fig(nnl(iv)) = fig(nnl(iv))(1:lfig)//char
          lfig = lfig+1
          go to 5
        end if
      else if (char .eq. 'r') then
c
c  We have a rest, so get inodur and dot
c
        nnl(iv) = nnl(iv) + 1
        rest(iv,nnl(iv)) = .true.
        call getchar(line,iccount,char)
        if (lastchar) return
        read(char,'(i1)')inodur
        dot = 'x'
        call getchar(line,iccount,char)
        if (lastchar) return
        if (char .eq. 'd') then
          dot = char
        end if 
        nodur(iv,nnl(iv)) = ifnodur(inodur,dot)
        itsofar(iv) = itsofar(iv)+nodur(iv,nnl(iv))
        if (mod(itsofar(iv),lenbar) .eq. 0) then
          nbars = nbars+1
          nib(iv,nbars) = nnl(iv)
          if (lenbar .ne. lenbar1) then
c
c###  Just finished the pickup bar for this voice.
c
            lenbar = lenbar1
            itsofar(iv) = 0
          end if
        end if 
      end if
3     if (char .eq. '/') then
c
c  Start a new voice for this line
c
        if (iv .eq. nv) then
          loop = .false.
        else
          if (lenbar0.ne.0 .and. firstline) lenbar = lenbar0
          nbars = 0
          iv = iv+1
        end if
      end if
      return
      end
      subroutine getchar(line,iccount,mychar)
c
c  Gets the next character out of line*80.  If pointer iccount=80 on entry,
c  then reads in a new line.  Resets iccount.  Ends program if no more input.  
c
      logical lastchar
      common /comget/ lastchar
      character*1 mychar,s
      character*80 line
c  Platform-independent backslash
      s = char(92)
      if (iccount .eq. 80) then
        read(10,'(a80)',end=999)line
        iccount = 0
      end if
      iccount = iccount+1
      mychar = line(iccount:iccount)
      return
999   continue
      write(11,'(a)')s//'finmorceau'//s//'bye'
      lastchar = .true.
      return
      end
      function log2(n)
        log2 = alog(n*1.)/0.69315+.01
      return
      end
      function ifnolev(no,oct)
        character*1 no
        integer oct
        ifnolev = 7*oct+mod(ichar(no)-92,7)+1
      return
      end
      function ifnodur(idur,dot)
        character*1 dot
        if(idur .eq. 3)then
          ifnodur=3
        else if(idur .eq. 1) then
          ifnodur=6 
        else if(idur .eq. 8) then
          ifnodur=12 
        else if(idur .eq. 4) then
          ifnodur=24 
        else if(idur .eq. 2) then
          ifnodur=48
        else if(idur .eq. 0) then
          ifnodur=96
        else 
          print*,'You entered an invalid note value'
          stop
        end if
        if (dot .eq. 'd') ifnodur = ifnodur*1.5+.5
      return
      end
      function ncmidf(clef)
      character*1 clef
      if (clef.eq.'t') then
        ncmidf = 35
      else if (clef .eq. 'b') then
        ncmidf = 23
      else if (clef .eq. 'a') then
        ncmidf = 29
      end if
      return
      end
      subroutine beamend(notex,lnote)
      include 'pmtex.inc'
      character*1 notef
      character*25 notex
        ip = list(2,jn)
        notex = s  
        lnote = 1
c
c First check if multiplicity has increased
c
        if (acc(iv,ip-1) .ne. 'a') then
          mp = mult(iv,ip-1)
        else
          mp = mult(iv,ip-2)
        end if
        if (mult(iv,ip) .gt. mp) then
          notex = notex(1:1)//'t'
          lnote = lnote+1
          do 1 im = 1 , mult(iv,ip)
            notex = notex(1:lnote)//'b'
            lnote = lnote+1
1         continue
          notex = notex(1:lnote)//ul(iv,ibmcnt(iv))
          lnote = lnote+2
          write(notex(lnote:lnote),'(i1)')iv
          notex = notex(1:lnote)//s
          lnote = lnote+1
        end if
c
c Now the normal beam termination
c
        notex = notex(1:lnote)//'tb'//ul(iv,ibmcnt(iv))
        lnote = lnote+4
        write(notex(lnote:lnote),'(i1)')iv
c
c  And now the note
c
        notex = notex(1:lnote)//s//'q'//hb(iv,ibmcnt(iv))
        lnote = lnote+4
        write(notex(lnote:lnote),'(i1)')iv
        notex = notex(1:lnote)//notef(nolev(iv,ip))
        lnote = lnote+1
      return
      end
      subroutine beamid(notex,lnote)
      include 'pmtex.inc'
      character*25 notex
      character*1 notef
        lnote = 1
        notex = s
        ip = list(2,jn)
c
c Check if multiplicity changes in a way requiring action
c
        mub = mult(iv,ip)-mult(iv,ip-1)
        if (acc(iv,ip-1).eq.'a') mub = mult(iv,ip)-mult(iv,ip-2)
        mua = mult(iv,ip+1)-mult(iv,ip)
        if (acc(iv,ip+1).eq.'a') mua = mult(iv,ip+2)-mult(iv,ip)
        if (mub.gt.0 .or. mua .lt. 0) then
c
c  Multiplicity has changed.
c
          lnote = 2
          if (mua .ge. 0) then
            notex = s//'n'
          else
            notex = s//'t'
          end if
          do 1 im = 1 , mult(iv,ip)
            notex = notex(1:lnote)//'b'
            lnote = lnote+1
1         continue
          notex = notex(1:lnote)//ul(iv,ibmcnt(iv))
          lnote = lnote+2
          write(notex(lnote:lnote),'(i1)')iv
          notex = notex(1:lnote)//s
          lnote = lnote+1
        end if
c
c Now put in the note
c
        notex = notex(1:lnote)//'q'//hb(iv,ibmcnt(iv))
        lnote = lnote+2
        if (acc(iv,ip).ne.'a'.and. 2**log2(int(nodur(iv,ip)/3.+.1)).ne.
     *                                    int(nodur(iv,ip)/3.+.1)) then      
          notex = notex(1:lnote)//'p'
          lnote = lnote+1
        end if
        lnote = lnote+1
        write(notex(lnote:lnote),'(i1)')iv
        notex = notex(1:lnote)//notef(nolev(iv,ip))
        lnote = lnote+1
      return
      end
      subroutine beamstrt(notex,lnote,nornb,ihornb)
      include 'pmtex.inc'
      logical figbass
      character*1 notef
      character*25 notex
      real*4 xelsk(16)
      integer ipb(16),nornb(5),ihornb(5,16)
      common /comfig/ ifigdrop(50),iline,figbass
        ibc = ibmcnt(iv)
        n1 = ipl(iv,ibm1(iv,ibc))
        n2 = ipl(iv,ibm2(iv,ibc))
        notex = s//'i'
        lnote = 2
        multb = mult(iv,ibm1(iv,ibc))
        do 1 im = 1 , multb
          notex = notex(1:lnote)//'b'
          lnote = lnote+1
1       continue
        notex = notex(1:lnote)//ul(iv,ibc)
        lnote = lnote+2
c
c  Put in index for the beam
c
        write(notex(lnote:lnote),'(i1)')iv 
        call SetupB(xelsk,nnb,sumx,sumy,ipb,islope,nolev1,nornb)
c#### Get 'floor' zmin for figures 
        if (figbass .and. iv.eq.1) then
          zmult = 1.2*(multb-1)
          ymin = 100.
          do 3 inb = 1, nnb
            if (fig(ipb(inb)).ne.'x') then
              if (ul(1,ibc) .eq. 'u') then
                ybot = nolev(1,ipb(inb))
              else
                ybot = islope/slfac*xelsk(inb)+nolev1-stemlen-zmult
              end if
              ymin = min(ymin,ybot)
            end if
3         continue
          maxdrop = ncmid(1)-4-ymin+5.01
          ifigdrop(iline) = max(ifigdrop(iline),maxdrop)
        end if
c#### Slope & height analysis done.  Put in name start level and slope
        notex = notex(1:lnote)//notef(nolev1)//'{'
        lnote = lnote+5
        write(notex(lnote-2:lnote),'(i2,a1)')islope,'}'
c#### Compute ornament levels if needed
        if (nornb(iv) .gt. 0) then
          NomOrnLev = ncmid(iv)+5
          iorn = 0
          do 8 inb = 1 , nnb
            if (orn(iv,ipb(inb)) .ne. 'x') then
              iorn = iorn+1
              if (ul(iv,ibc) .eq. 'l') then
                ihornb(iv,iorn) = max(nolev(iv,ipb(inb))+2,NomOrnLev)
              else
                ybeam = nolev1+stemlen+islope*xelsk(inb)/slfac-1
     *                  +1.2*(multb-1)
                ihornb(iv,iorn) = max(ni(ybeam+3.5),NomOrnLev)
              end if
            end if
8         continue
c#### Henceforth norn(iv) will be a counter.  Be sure to zero it out when
c     beam is finished
          nornb(iv) = 1
        end if
      return
      end
      subroutine beamn1(notex,lnote)
      include 'pmtex.inc'
      character*1 notef
      character*25 notex
c     real*4 xelsk(16)
c     integer ipb(16)
        lnote = 3
        notex = s//'q'//hb(iv,ibmcnt(iv))
c
c  Check for dot
c
        n1 = ipl(iv,ibm1(iv,ibmcnt(iv)))
        nd = nodur(iv,list(2,n1))
        if (nd.ne.0.and.2**log2(int(nd/3.+.1)).ne.int(nd/3.+.1))then
          notex = notex(1:lnote)//'p'
          lnote = lnote+1
        end if
        lnote = lnote+1
        write(notex(lnote:lnote),'(i1)')iv
        notex = notex(1:lnote)//notef(nolev(iv,list(2,n1)))
        lnote = lnote+1
      return
      end        
      subroutine addstr(notex,lnote,sout,lsout)
        character*25 notex
        character*80 sout
        if (lsout+lnote .gt. 72) then
          write(11,'(a)')sout(1:lsout)//'%'
          lsout = 0
        end if 
        if (lsout .gt. 0) then
          sout = sout(1:lsout)//notex(1:lnote)
        else
          sout = notex(1:lnote)
        end if
        lsout = lsout+lnote
      return
      end
      character*1 function notef(nolev)
        if (nolev .le. 26) then
          notef = char(nolev+52)
        else
          notef = char(nolev+70)
        end if
      return
      end
      subroutine notex(mynotex,lnote)
      include 'pmtex.inc'
      common /comfig/ ifigdrop(50),iline,figbass
      logical figbass
      character*1 ulf,ud
      character*25 mynotex
      character*1 note,notef 
        nole = nolev(iv,list(2,jn))
        nodu = nodur(iv,list(2,jn)) 
        ud = ulf(1.*(nole-ncmid(iv)))
c####  Check figure level
        if (figbass .and. iv.eq.1 
     *       .and. fig(list(2,jn)).ne.'x') then
          if (ud .eq. 'u') then
c#### Upper stem, fnole (in noleunits) set by notehead
            fnole = nole
          else
c##### Lower stem, fnole set by bottom of stem
            fnole = nole-stemlen
          end if
          zmin = fnole-ncmid(1)+4 
          ifigdrop(iline) = max(ifigdrop(iline),int(4-zmin+.5))
        end if
        if (.not.rest(iv,list(2,jn))) then
          lnote = 5
          note = notef(nole)
          if (int(nodu/3.+.1) .eq. 2**log2(int(nodu/3.+.1))) then
            if (nodu .eq. 3) then
              mynotex =s//'ccc'//ud//' '//note
              lnote = 7
            else if (nodu .eq. 6) then
              mynotex =s//'cc'//ud//' '//note
              lnote = 6
            else if (nodu .eq. 12) then
              mynotex =s//'c'//ud//' '//note
            else if (nodu .eq. 24) then
              mynotex =s//'q'//ud//' '//note
            else if (nodu .eq. 48) then
              mynotex =s//'h'//ud//' '//note
            else if (nodu .eq. 96) then
              mynotex =s//'wh'//' '//note
            end if
          else
            lnote = 6
            if (nodu .eq. 18) then
              mynotex =s//'c'//ud//'p'//' '//note
            else if (nodu .eq. 36) then
              mynotex =s//'q'//ud//'p'//' '//note
            else if (nodu .eq. 72) then
              mynotex =s//'h'//ud//'p'//' '//note
            else if (nodu .eq. 9) then
              mynotex =s//'c'//ud//'p'//' '//note
              lnote = 7  
            end if
          end if
        else 
c
c  "rest" (real, whole-bar, or accidental gap)
c
          lnote = 3
c
c  First check for whole-bar rest. 
c
          if (acc(iv,list(2,jn)) .eq. 'b') then
            mynotex = s//'sk'
          else if (acc(iv,list(2,jn)) .eq. 'w') then
            mynotex = s//'rlap{'//s//'qsk'//s//'pause}'
            lnote = 17
c
c  Now check for accidental gap
c
          else if (acc(iv,list(2,jn)) .eq. 'a') then
            mynotex = s//'ask'
            lnote = 4
          else if (nodu .eq. 3) then
            mynotex =s//'hs'
          else if (nodu .eq. 6) then
            mynotex =s//'qs'
          else if (nodu .eq. 12) then
            mynotex =s//'ds'
          else if (nodu .eq. 24) then
            mynotex =s//'qp'
          else if (nodu .eq. 48) then
            mynotex =s//'hpause'
            lnote = 7
          else if (nodu .eq. 96) then
            mynotex =s//'pause'
            lnote = 6
          end if
        end if
      return
      end
      subroutine fillbeat(lenbeam,ip1,numbms)
      integer numbms(5)
      include 'pmtex.inc'
      character*1 ulf,hbf 
      in1 = ipl(iv,ip1)
      it1 = list(3,in1)
      it2 = it1+lenbeam
      itend = it1+nodur(iv,ip1)
c### Bounce out if (a) starting time not on an even beat,
c                  (b) rest
c                  (c) a single note fills the beat
c                  (d) too close to the end of the bar
c                  (e) note is quarter or longer
      if (mod(it1,lenbeam).ne.0 .or. rest(iv,ip1) .or. 
     *    nodur(iv,ip1).eq.lenbeam .or. itend.ge.it2 .or.
     *    nodur(iv,ip1).ge.24)     return
c
c In the previous line, "if ... rest" makes beams starting with spaced
c accidentals begin on the note rather than the accidental.
c
      do 1 ip = ip1+1 , nn(iv)
c Add new note
        itend = itend+nodur(iv,ip)
c### Check for real rest or gone past end of potential beam or note >= quarter
        if ((rest(iv,ip).and.acc(iv,ip).ne.'a') .or. itend.gt.it2
     *      .or. nodur(iv,ip).ge.24)  return
c
c If "rest" at this point, it has to be an accidental skip
c
        if (itend.lt.it2.or.(itend.eq.it2.and.rest(iv,ip))) go to 1
c
c  AHA beams
c
        numbms(iv) = numbms(iv) + 1
        ibm1(iv,numbms(iv)) = ip1
        ip2 = ip
c
c  Special check for 4 eighth notes or 3 8ths + 8th rest
c
c       if (mod(it1,48).eq.0 .and. nodur(iv,ip1).eq.12 
c    *      .and. nodur(iv,ip2).eq.12 .and. lenbar.eq.96 .and.
c    *      nn(iv).ge.ip2+2 .and. nodur(iv,ip2+1).eq.12
c    *      .and. nodur(iv,ip2+2).eq.12 .and. .not.rest(iv,ip2+1))
c    *      then
c         if (rest(iv,ip2+2)) then 
c           ip2 = ip2+1
c         else
c           ip2 = ip2+2
c         end if
c       end if
        if (mod(it1,48).eq.0 .and. nodur(iv,ip1).eq.12 
     *      .and. nodur(iv,ip2).eq.12 .and. lenbar.eq.96 .and.
     *      nn(iv).ge.ip2+2 ) then
c#### We have 2 1/8th notes.  Look for third and fourth.
          ixtra = 0
          do 3 jp = ip2+1 , nn(iv)   
            if ((nodur(iv,jp).ne.12.and.acc(iv,jp).ne.'a') .or.
     *             (ixtra.eq.0.and.rest(iv,jp))) go to 4
            if (acc(iv,jp) .eq. 'a') go to 3
            ixtra = ixtra+1
            if (ixtra .eq. 2) then
              if (rest(iv,jp)) then 
c#### 3-1/8th note beam.  Back up to note
                ip2 = jp-1
5               if (rest(iv,ip2)) then
                  ip2 = ip2-1
                  go to 5
                end if
              else
                ip2 = jp
              end if
              go to 4
            end if
3         continue
        end if
4       continue
        ibm2(iv,numbms(iv)) = ip2
        sum = 0.
        elskbm = 0.
        nask = 0 
        do 2 iip = ip1, ip2
          if (rest(iv,iip)) then 
            mult(iv,iip) = 0
            nask = nask + 1
          else
            l2 = log2(int(nodur(iv,iip)/3.+.1))
            sum = sum+nolev(iv,iip)
            mult(iv,iip) = 3-l2
          end if
2       continue
        ul(iv,numbms(iv)) = ulf(sum/(ip2-ip1+1-nask)-ncmid(iv))
        hb(iv,numbms(iv)) = hbf(sum/(ip2-ip1+1-nask)-ncmid(iv))
        return
1     continue
      print*,'You should not be here in fillbeat'
      stop
      end
      character*1 function ulf(xnolev)
        if (xnolev .ge. 0.) then
          ulf = 'l'
        else
          ulf = 'u'
        end if
      return
      end
      character*1 function hbf(xnolev)
        if (xnolev .ge. .0) then
          hbf = 'b'
        else
          hbf = 'h'
        end if
      return
      end
      subroutine makeabar()
      include 'pmtex.inc'
      common /combeam/ lenbeam
      integer it(5),cnn(5),istart(20),istop(20),itstart(20),
     *   nspace(20),nindex(20),numbms(5),nornb(5),ihornb(5,16)  
      character*1 notef
      character*80 sout
      character*5 nstart(6)
      character*25 mynotex
      logical bspend
      data nstart /'notes','Notes','NOtes','NOTes','NOTEs',
     *              'NOTES'/
      do 1 iv = 1 , nv
        if (ibar .gt. 1) then
          nn(iv) = nib(iv,ibar)-nib(iv,ibar-1)
        else
          nn(iv) = nib(iv,ibar)
        end if
1     continue
c
c initialize list note counter, time(iv), curr. note(iv)
c
      ilnc = 1
      do 4 iv = 1 , nv
        if (nn(iv) .gt. 1) then
          it(iv) = nodur(iv,1)
        else
          it(iv) = 1000
        end if
        cnn(iv) = 1
        list(1,ilnc) = iv
        list(2,ilnc) = 1
        ilnc = ilnc+1
4     continue
c
c  Build the list
c
5     continue
c
c  Determine which voice comes next from end of notes done so far.
c  itmin is the earliest ending time of notes done so far
c
      itmin = 1000
      do 6 iv = 1 , nv
        itminn = min(itmin,it(iv))
        if(itminn .lt. itmin) then
          itmin = itminn
          ivnext = iv
        end if
6     continue
      if (itmin .eq. 1000) go to 7
      list(1,ilnc) = ivnext
      cnn(ivnext) = cnn(ivnext)+1
      list(2,ilnc) = cnn(ivnext) 
      list(3,ilnc) = itmin
c
c  Check if this voice is done
c           
      if (cnn(ivnext) .eq. nn(ivnext)) then
        it(ivnext) = 1000
      else
        it(ivnext) = it(ivnext)+nodur(ivnext,cnn(ivnext)) 
      end if
      ilnc = ilnc+1
      go to 5
7     continue
      ntot = ilnc-1
      do 8 in = 1 , ntot-1
        list(4,in) = list(3,in+1)-list(3,in)
8     continue
      list(4,ntot) = nodur(list(1,ntot),list(2,ntot))
c
c  Done w/ list, but for special checks. First, for full-bar rests
c
      do 30 iv = 1 , nv
        if (nodur(iv,1).eq.lenbar.and.rest(iv,1).and.ntot.gt.nv) then
c
c  Find the last list position (in) before the half-bar
c
          do 31 in = 1 , ntot-1
            if (list(3,in+1) .ge. lenbar/2) go to 32
31        continue
          print*,'Mess-up looking for half-bar'
          stop
32        itwrest = list(3,in)
c
c  Backup to spot for inserting rest marker, i.e., one to the right of 
c  the first place where either list(1)<iv or list(3)<itwrest 
c
          do 33 iin = in-1 , 1 , -1
            if(list(1,iin).lt.iv.or.list(3,iin).lt.itwrest)go to 34
33        continue
          print*,'Problem backing up from half bar'
c         stop
34        infr = iin+1
          call add2list(infr,2,itwrest,lenbar-itwrest,'w',.true.,
     *     ntot,istart,istop,nb)
          nodur(iv,1) = itwrest
          acc(iv,1) = 'b'
        end if
30    continue  
c
c  A kluged up loop for building note blocks:
c
      ib = 1 
      istart(1) = 1
      nspace(1) = 0
      in = 1 
9     continue
        if (in .eq. ntot) then
          if (nspace(ib) .eq. 0) nspace(ib)=list(4,in)
          istop(ib) = ntot
c Now we flow out of this if and into block-building      
        else if (nspace(ib) .eq. 0) then
c nspace hasn't been set yet, so 
c and tentatively set:
          nspace(ib) = list(4,in)
          if (nspace(ib) .eq. 0) then
            in=in+1
          else
            istop(ib) = in
          end if
          go to 9
        else if (list(4,in+1) .eq. 0) then
c This is not the last note in the group, so
          in = in+1
          go to 9 
        else if (list(4,in+1) .eq. nspace(ib)) then
c Keep spacing the same, update tentative stop point
          in = in+1
          istop(ib) = in
          go to 9
        end if
c
c At this point istart and istop are good, so on to next block 
c
        itstart(ib) = list(3,istart(ib))
        nindex(ib) = log2(nspace(ib)/2)+1
        if (istop(ib) .eq. ntot) go to 15
        ib = ib+1
        istart(ib) = istop(ib-1)+1
        in = istart(ib)
c
c Set tentative block space for new block
c
        nspace(ib) = list(4,in)
        istop(ib) = in
      go to 9          
15    continue
      nb = ib
c
c  Now add to list special codes for accidental skips.  This is a loop on
c  in up to ntot, but ntot increases when a skip is added, so loop manually
c  Must bypass this loop if all there are are whole rests.
      if (ntot .eq. nv) go to 40
      in = 2
39    continue
        jv = list(1,in)
        ip = list(2,in)
        itim = list(3,in)
        if ((acc(jv,ip).eq.'f' .or. acc(jv,ip).eq.'n'
     *      .or. acc(jv,ip).eq.'s') .and. nodur(jv,ip-1).le.6 .and.
     *       ip.ge.2 .and. acc(jv,ip-1).ne.'a') then
c
c  Need accidental skip. Find block # for list position "in".
c
          do 45 ib = 1 , nb
            if (istop(ib) .ge. in) go to 46
45        continue
          print*,'Got lost looking for ib!!'
46        continue
          do 42 iv = nv , 1 , -1
            if (iv .eq. jv) then
              iip = ip
              iin = in
              iitim = itim
            else if (nn(iv) .eq. 1) then
              go to 42
            else
c 
c  Find ip# for this voice at this itim !!!  
c
              do 43 iin = 2 , ntot
                if (list(1,iin).eq.iv.and.list(3,iin).ge.itim)then
c
c  Check if in the same block as the offending accidental
c
                  if (istop(ib) .ge. iin) go to 44
c
c  Note is in next block, so no skip needed.
c
                  go to 42
                end if
43            continue
c
c No skip needed, since no new notes after the one in question, so
c
              go to 42
44            iip = list(2,iin)
              iitim = list(3,iin)
            end if
            call add2list(iin,iip,iitim,0,'a',.true.,ntot,
     *         istart,istop,nb)
42        continue
        end if
      if (in .eq. ntot) go to 40 
      in = in+1
      go to 39
40    continue              
c
c  Invert the list of places, to make it easier to analyze a voice
c
      do 13 in = 1 , ntot
        ipl(list(1,in),list(2,in)) = in
13    continue 
c
c Now before writing output, analyze for beams
c
      do 20 iv = 1 , nv
        numbms(iv) = 0
        do 21 ip = 1 , nn(iv)
          nbold = numbms(iv)
c### For each ip beyond the end of the last beam, see if a quarter note
c### starting here is filled up with notes:
          if (numbms(iv).eq.0 .or. ip.gt.ibm2(iv,numbms(iv))) then
            call fillbeat(lenbeam,ip,numbms)
c### If no new quarter-note beam starts here, check for eighth-note beam
            if (numbms(iv).eq.nbold .and. acc(iv,ip).ne.'a'.and.
     *             mod(lenbeam,24).eq.0) then
c### Starting time
              ittemp = list(3,ipl(iv,ip))
              do 22 iip = ip , nn(iv)
                call fillbeat(lenbeam/2,iip,numbms)
                itendnow = list(3,ipl(iv,iip))+nodur(iv,iip)
                if (ittemp+lenbeam.le.itendnow
     *              .or. mod(itendnow,lenbeam).eq.0) go to 21
22            continue
            end if
          end if
21      continue
20    continue
c
c  Finally ready to write output
c 
      do 25 iv = 1, nv
        ibmcnt(iv) = 1
        beamon(iv) = .false.
        nornb(iv) = 0
25    continue        
      bspend = .false.
      do 16 ib = 1 , nb
        sout = s//nstart(nindex(ib)) 
        lsout = 6
        do 11 iv = 1 , nv
          if (iv .gt. 1) call addstr(sepsym,1,sout,lsout)
          itnow = itstart(ib)
          do 10 jn = istart(ib), istop(ib)
            if (list(1,jn) .ne. iv) go to 10
            ip = list(2,jn)
12          if (list(3,jn) .gt. itnow) then   
c Need skips
              call addstr(s//'sk',3,sout,lsout)
              itnow = itnow+nspace(ib)
              go to 12
            end if
c
c  Skip space for accidentals
c
            if (acc(iv,ip) .eq. 'a') then
              call addstr(s//'ask',4,sout,lsout)
              go to 10
            end if
c
c  Accidentals
c
            if (acc(iv,ip) .eq. 's') then
              call addstr(s//'xsh '//
     *             notef(nolev(iv,ip)),6,sout,lsout)
            else if (acc(iv,ip) .eq. 'f') then
              call addstr(s//'xfl '//
     *             notef(nolev(iv,ip)),6,sout,lsout)
            else if (acc(iv,ip) .eq. 'n') then
              call addstr(s//'xna '//
     *             notef(nolev(iv,ip)),6,sout,lsout)
            end if             
c####  Check for figure
            if (iv.eq.1 .and. fig(ip).ne.'x') 
     *        call putfig(fig(ip),sout,lsout)
c####  See if a beam starts here
            if (numbms(iv).gt.0 .and. ibmcnt(iv).le.numbms(iv)
     *          .and. ibm1(iv,ibmcnt(iv)) .eq. ip) then
              call beamstrt(mynotex,lnote,nornb,ihornb)
              call addstr(mynotex,lnote,sout,lsout)
              beamon(iv) = .true.
              bspend = .true.
            end if
c#### Check for ornaments
            if (orn(iv,ip).ne.'x') then
              if (nornb(iv) .ne. 0) then
c#### In a beam, height has already been calculated
                ihorn = ihornb(iv,nornb(iv))
                nornb(iv) = nornb(iv)+1
              else if (nolev(iv,ip) .ge. ncmid(iv)) then
c#### Separate note, lower stem
                ihorn = max(ncmid(iv)+5,nolev(iv,ip)+2)
              else
c#### Upper beam, must clear the stem
                ihorn = max(ncmid(iv)+5,nolev(iv,ip)+2+ni(stemlen-0.5))
              end if
              if (orn(iv,ip) .eq. 't') then
                mynotex = s//'pince '
                lnote = 8
              else if (orn(iv,ip) .eq. 'm') then
                mynotex=s//'mordant '
                lnote = 10
              else if (orn(iv,ip) .eq. 's') then
                mynotex=s//'mtr '
                lnote = 6
              end if
              call addstr(mynotex(1:lnote-1)//notef(ihorn),lnote,
     *                   sout,lsout)
            end if
c####  Is a beam start pending?
            if (bspend) then
              call beamn1(mynotex,lnote)
              bspend = .false.
c####  Is a beam ending?
            else if (numbms(iv).gt.0 .and. ibmcnt(iv).le.numbms(iv) 
     *           .and. ibm2(iv,ibmcnt(iv)) .eq. ip) then
              call beamend(mynotex,lnote)
              nornb(iv) = 0
              ibmcnt(iv) = ibmcnt(iv)+1
              beamon(iv) = .false.
c####  Or if we're in the middle of a beam
            else if (numbms(iv).gt.0 .and. beamon(iv)) then
              call beamid(mynotex,lnote)
            else
c####  Write a separate note
              call notex(mynotex,lnote)
            end if
            call addstr(mynotex,lnote,sout,lsout)
            itnow = itnow+nspace(ib)
10        continue              
11      continue
        call addstr(s//'enotes',7,sout,lsout) 
        if (lsout .gt. 0) write(11,'(a)')sout(1:lsout)//'%'
16    continue           
      return
      end
      subroutine add2list(infr,newip,newstrt,newdur,newacc,newrest,
     *     ntot,istart,istop,nb)
c
c  This inserts into the list a new "note" at location infr.  Inputs vars are
c     (iv) = voice # (in common)
c     newip = position in voice, from beginning of bar
c     newstrt = starting time of new "note"
c     newdur =  duration
c     newacc = accidental value
c     newrest = rest value
c     
        include 'pmtex.inc'
        character*1 newacc
        logical newrest
        integer istart(20),istop(20)
c
c  Move everything in the list to the right by one spot, and adjust ip
c    for notes in affected voice.
c
        do 34 in = ntot , infr , -1
          if (list(1,in).eq.iv) list(2,in) = list(2,in)+1
          do 35 il = 1 , 4
            list(il,in+1) = list(il,in)
35        continue
34      continue
c
c  Move everything in nodur,rest,acc,nolev to the right by one 
c
        do 36 ip = nnl(iv) , newip , -1
          nodur(iv,ip+1) = nodur(iv,ip)
          nolev(iv,ip+1) = nolev(iv,ip)
          acc(iv,ip+1) = acc(iv,ip)
          orn(iv,ip+1) = orn(iv,ip)
          rest(iv,ip+1) = rest(iv,ip)
          if (iv .eq. 1) fig(ip+1) = fig(ip)
36      continue
        nnl(iv) = nnl(iv)+1
        do 37 iibar = ibar , nbars 
          nib(iv,iibar) = nib(iv,iibar)+1
37      continue
        ntot = ntot+1
        nn(iv) = nn(iv)+1
        nodur(iv,newip) = newdur
        rest(iv,newip) = newrest
        acc(iv,newip) = newacc
        orn(iv,newip) = 'x'
        if (iv.eq.1) fig(newip) = 'x'
        list(1,infr) = iv
        list(2,infr) = newip
        list(3,infr) = newstrt
        list(4,infr) = list(3,infr+1)-list(3,infr)
        list(4,infr-1) = list(3,infr)-list(3,infr-1)
c
c Check the note blocks
c
        do 38 ib = 1 , nb
          if (infr .le. istop(ib)) istop(ib) = istop(ib)+1
          if (infr .lt. istart(ib)) istart(ib) = istart(ib)+1
38      continue            
      return
      end
      subroutine putfig(fig,sout,lsout)
      character*6 fig
      character*80 sout
      character*1 ch1,ch2,s
      character*2 nof,nofa
      integer tof,tofa
c  Platform-independent backslash
        s = char(92)
        ic = 1
        nof = '0'
        nofa = '-1'
c
c  Beginning of loop \/ \/
c
1       ch1 = fig(ic:ic)
        if (ch1 .eq. ' ') go to 2
c
c  Just starting or not yet finished
c
        lnof = 1
        tof = ord(nof)
        nof = char(tof+48)
        if (tof .gt. 9) then
         lnof = 2
         tof = ord(nof)
         nof = '1'//char(tof-10+48)
        end if
        tofa=ord(nofa)
        if (tofa .eq.-1) then
          lnofa = 2
          nofa = '-1'
        else if (tofa .lt. 10) then
          lnofa = 1
          nofa = char(tofa+48)
        else
          lnofa = 2
          nofa = '1'//char(tofa+38)
        end if
        if (ch1.eq.'#'.or.ch1.eq.'-'.or.ch1.eq.'n') then
          ic = ic+1
          ch2 = fig(ic:ic)
          if (ch2 .eq. ' ') then
c
c  Figure is a stand-alone accidental, so must be centered
c
            if (ch1 .eq. '#') then
              call addstr(s//'Figu{'//nofa(1:lnofa)//
     *          '}{'//s//'smalls@harp}',21+lnofa,sout,lsout)
            else if (ch1 .eq. '-') then
              call addstr(s//'Figu{'//nofa(1:lnofa)//
     *          '}{'//s//'smallf@lat}',20+lnofa,sout,lsout)
            else if (ch1 .eq. 'n') then
              call addstr(s//'Figu{'//nofa(1:lnofa)//
     *                '}{'//s//'smalln@at}',19+lnofa,sout,lsout)
            end if
            go to 2
          else 
c
c  Figure is an accidental followed by a number
c  First put the accidental (offset to the left)
c
            if (ch1 .eq. '#') then
              call addstr(s//'Figu{'//
     *               nofa(1:lnofa)//'}{'//s//'fsmsh}',
     *               15+lnofa,sout,lsout)      
            else if (ch1 .eq. '-') then
              call addstr(s//'Figu{'//
     *               nofa(1:lnofa)//'}{'//s//'fsmfl}',
     *               15+lnofa,sout,lsout)      
            else if (ch1 .eq. 'n') then
              call addstr(s//'Figu{'//
     *               nofa(1:lnofa)//'}{'//s//'fsmna}',
     *               15+lnofa,sout,lsout)      
            end if
c
c  Now put the number
c
            call addstr(s//'Figu{'//nof(1:lnof)//'}{'//ch2//'}',
     *           10+lnof,sout,lsout)      
          endif
        else
c
c  Figure is a single number
c
          call addstr(s//'Figu{'//nof(1:lnof)//'}{'//ch1//'}',
     *           10+lnof,sout,lsout)      
        end if
        ic = ic+1
        tof = ord(nof)
        tof = tof+4
        nof = char(tof+48)
        tofa = ord(nofa)
        tofa = tofa+4  
        nofa = char(tofa+48)
        go to 1
2     continue
      return
      end
      subroutine topfile
     *     (basename,lbase,nv,clef,noinst,musicsize,figbass)
      common /comtop / itopfacteur,ibotfacteur,interfacteur,
     *   isig,fracindent,imeter,mtrnum,mtrden,iwaskpt,widthpt,height
      common /comtop/ iname(5)
      character*24 basename,iname
      character*40 tstring
      character*1 clef(5),clefnum,s
      character*3 rnum(5)
      logical figbass
      data rnum /'i  ','ii ','iii','iv ','v  '/
c Platform-independent backslash
      s = char(92)
      write(11,'(a)')'%%%%%%%%%%%%%%%%%'
      write(11,'(a)')'%'
      write(11,'(a)')'% '//basename(1:lbase)//'.tex'
      write(11,'(a)')'%'
      write(11,'(a)')'%%%%%%%%%%%%%%%%'
      write(11,'(a)')s//'input musicnft'
      write(11,'(a)')s//'input musicvbm'
      write(11,'(a)')s//'input musictex'
      write(11,'(a)')s//'input musicsty'
      write(11,'(a)')s//'input musictrp'
      write(11,'(a)')s//'input pmtex'
      if (figbass) 
     *      write(11,'(a)')s//'input '//basename(1:lbase)//'.fig'
      write(11,'(a)')s//'def'//s//'autol#1#2#3{'
      if (figbass) 
     *   write(11,'(a)')s//'global'//s//'advance'//
     *             s//'sysno by 1'//s//'relax'//s//'fixdrop%'
      write(11,'(a)')s//'autolines{#1}{#2}{#3}}'
      write(11,'(a14,i1,a4)')s//'def'//s//
     *             'ask{'//s//'off{',iwaskpt,'pt}}'
      write(11,'(a11,i2,a1)')s//'musicsize=',musicsize,'%'
      write(11,'(a)')s//'tracingstats=2'//s//'relax'
      write(11,'(a7,i3,a2)')s//'hsize=',int(widthpt+.1),'pt'
      write(11,'(a7,i3,a2)')s//'vsize=',int(height+.1),'pt'
      nvp = nv
      if (noinst .eq. 0) nvp = 1
      write(11,'(a19,i1,a1)')s//'def'//s//'nbinstruments{',nvp,'}'
      write(11,'(a16,i2,a1)')s//'def'//s//
     *                      'topfacteur{',itopfacteur,'}'
      write(11,'(a19,i2,a1)')
     *       s//'def'//s//'bottomfacteur{',ibotfacteur,'}'
      write(11,'(a18,i2,a1)')
     *       s//'def'//s//'interfacteur{',interfacteur,'}'
      if (noinst .gt. 0) then
c
c  There are nv differenet instruments
c
        do 1 iv = 1 , nv
          write(11,'(a16)')s//'nbportees'//rnum(iv)//'=1%'
          write(11,'(a)')s//'global'//s//'cleftoks'//rnum(iv)//
     *                     '={{'//clefnum(clef(iv))//'}{0}{0}{0}}%'
          do 3 lname = 24 , 2 , -1
            if (iname(iv)(lname:lname) .ne. ' ') go to 4
3         continue
4         continue
          write(11,'(a)')s//'def'//s//'instrument'//rnum(iv)//
     *         '{'//iname(iv)(1:lname)//'}'
1       continue
      else
c
c  There is one inst. with nv voices
c
        write(11,'(a12,i1)')s//'nbporteesi=',nv
        write(*,'(a12,i1)')s//'nbporteesi=',nv
        tstring = s//'global'//s//'cleftoksi={{0}{0}{0}{0}}'
        write(*,'(a)')tstring
        do 2 iv = 1 , nv
          iposn = 18+3*iv
          tstring(iposn:iposn) = clefnum(clef(iv))
          write(*,'(a)')tstring
2       continue
        write(11,'(a)')tstring
      end if
      write(11,'(a19,i2,a2)')s//'signaturegenerale{',isig,'}%'
      write(11,'(a)')s//'def'//s//'gluemaxskip{7pt}%'
      if (imeter .eq. 0) then
        write(11,'(a25,i2,a2,i2,a3)')
     *           s//'generalmeter{'//s//'meterfrac{',
     *           mtrnum,'}{',mtrden,'}}%'
      else if (imeter .le. 4) then
          write(11,'(a21,i1,a2)')
     *             s//'generalmeter{'//s//'meterN',imeter,'}%'
      else if (imeter .eq. 5) then
        write(11,'(a)')s//'generalmeter'//s//'allabreve%'
      else if (imeter .eq. 6) then
        write(11,'(a)')s//'generalmeter'//s//'meterC%'
      end if
      ipi = fracindent*widthpt+.1
      if (ipi .lt. 10) then
        write(11,'(a11,i1,a2)')s//'parindent ',ipi,'pt'
      else
        write(11,'(a11,i2,a2)')s//'parindent ',ipi,'pt'
      end if
      write(11,'(a)')s//'null'//s//'bigskip'
      write(11,'(a)')s//'debutmorceau'
      write(11,'(a)')s//'def'//s//'freqbarno{5}'
      write(11,'(a)')s//'linesinpage=0'//s//'relax'
      return
      end
      function clefnum(clefname)
        character*1 clefname,clefnum
        if (clefname .eq. 'b') then
          clefnum = '6'
        else if (clefname .eq. 'a') then
          clefnum = '3'
        else if (clefname .eq. 't') then
          clefnum = '0'
        end if
      return
      end
      function ni(x)
        if (x .ge. 0.) then
          ni = x+0.5001
        else
          ni = x-0.5001
        end if
      return
      end
      subroutine SetupB(xelsk,nnb,sumx,sumy,ipb,islope,nolev1,nornb)
c
c The outer combo algorithm
c
      include 'pmtex.inc'
      real*4 xelsk(16),slope(120)
      integer ipb(16),nornb(5)
        ibc = ibmcnt(iv)
        n1 = ipl(iv,ibm1(iv,ibc))
        n2 = ipl(iv,ibm2(iv,ibc))
        nornb(iv) = 0
c
c Need to figure how many elemskips to the each note. Use the list,
c counting only those members that have a non-zero interval to next note
c
        elsksum = 0.
        nnb = 0
        sumx = 0.
        sumy = 0.
        do 2 in = n1, n2
          if (list(1,in).eq.iv .and. acc(iv,list(2,in)).ne.'a') then
            nnb = nnb+1
            ipb(nnb) = list(2,in)
            xelsk(nnb) = elsksum
            sumx = sumx+elsksum
            sumy = sumy+nolev(iv,ipb(nnb))
            if (orn(iv,ipb(nnb)) .ne. 'x') nornb(iv) = nornb(iv)+1
          end if
          if (in.lt.n2.and.list(4,in).ne.0) then
            nindx = log2(list(4,in)/2)+1
            elsperns = 2.**((nindx-1)/2.)
            elsksum = elsksum+elsperns
          end if
2       continue
        nsc = 0
        do 5 inb = 1 , nnb-1
          do 5 jnb = inb+1 , nnb
            nsc = nsc+1
            slope(nsc) = (nolev(iv,ipb(jnb))-nolev(iv,ipb(inb)))/
     *                   (xelsk(jnb)-xelsk(inb))
            if (abs(slope(nsc)) .lt. 1.e-4) then
              nsc = nsc+1
              slope(nsc) = slope(nsc-1)
              nsc = nsc+1
              slope(nsc) = slope(nsc-1)
            end if
5       continue
c       write(*,'(a7,1x,9f8.2/(8x,9f8.2))')'slopes:',(slope(i),i=1,nsc)
        if (nsc .eq. 1) then
          smed = slope(1)
          go to 6
        end if
        nscmid = nsc/2+1
        do 7 i = 1 , nscmid
          do 7 j = i+1 , nsc
            if (slope(j) .lt. slope(i)) then
              t = slope(j)
              slope(j) = slope(i)
              slope(i) = t
            end if
7       continue
        smed = slope(nscmid)
        if (nsc.eq.2*(nsc/2).and.
     *   abs(slope(nscmid-1)).lt.abs(slope(nscmid)))smed=slope(nscmid-1)
6       continue
        islope = ni(smed*slfac)
        if (iabs(islope) .gt. 9) islope = isign(9,islope)
c       beta = (sumy-smed*sumx)/nnb
        beta = (sumy-islope/slfac*sumx)/nnb
        nolev1 = beta+.5
c#### Check if any stems are too short
        smin = 100.
        iul = -1
        if (ul(iv,ibc) .eq. 'u') iul = 1
        ssq = 0.
        syb = 0.
        do 4 inb = 1 , nnb
          ybeam = nolev1+iul*stemlen+islope*xelsk(inb)/slfac
          syb = syb+ybeam
          ynote = nolev(iv,ipb(inb))
          off = ybeam-ynote
          if (inb .eq. 1) then
            off1 = off
          else if (inb .eq. nnb) then
            off2 = off
          end if
          ssq = ssq+off*off
          smin = min(smin,iul*off)
4       continue
        dnolev = 0.
        if (smin .lt. stemmin) then
          deficit = stemmin-smin
          nolevo = nolev1
          nolev1 = ni(nolev1+iul*deficit)
          dnolev = nolev1-nolevo
          off1 = off1+dnolev
          off2 = off2+dnolev
        end if
        ssq = ssq+2*dnolev*(syb-sumy)+dnolev**2
        if (sqrt(ssq/nnb) .gt. stemmax .and. 
     *    (abs(off1).lt.stemmax .or. abs(off2).lt.stemmax)) then
c#### The final check before switching is that first and last stems aren't
c     both excessive.
          call SetupB2(xelsk,nnb,sumx,sumy,ipb,islope,nolev1)
        end if
      return
      end
      subroutine SetupB2(xelsk,nnb,sumx,sumy,ipb,islope,nolev1)
c
c The MEAN SQUARE slope algorithm
c
      include 'pmtex.inc'
      real*4 xelsk(16)
      integer ipb(16)
        ibc = ibmcnt(iv)
        n1 = ipl(iv,ibm1(iv,ibc))
        n2 = ipl(iv,ibm2(iv,ibc))
c
c Need to figure how many elemskips to the each note. Use the list,
c counting only those members that have a non-zero interval to next note
c
        elsksum = 0.
        nnb = 0
        ipb(1) = n1
        sumx = 0.
        sumxx = 0.
        sumy = 0.
        sumxy = 0.
        do 2 in = n1, n2
          if (list(1,in).eq.iv .and. acc(iv,list(2,in)).ne.'a') then
            nnb = nnb+1
            ipb(nnb) = list(2,in)
            xelsk(nnb) = elsksum
            sumx = sumx+elsksum
            sumxx = sumxx+elsksum*elsksum 
            y = nolev(iv,list(2,in))
            sumy = sumy+y
            sumxy = sumxy+elsksum*y
          end if
          if (in.lt.n2.and.list(4,in).ne.0) then
            nindx = log2(list(4,in)/2)+1
            elsperns = 2.**((nindx-1)/2.)
            elsksum = elsksum+elsperns
          end if
2       continue
        delta = nnb*sumxx-sumx*sumx
        em = (nnb*sumxy-sumx*sumy)/delta
        islope = ni(em*slfac)
        if (iabs(islope) .gt. 9) then
          islope = isign(9,islope)
          beta = (sumy-islope/slfac*sumx)/nnb
        else
          beta = (sumy*sumxx-sumx*sumxy)/delta
        end if
        nolev1 = beta+.5
c#### Check if any stems are too short
        smin = 100.
        iul = -1
        if (ul(iv,ibc) .eq. 'u') iul = 1
        do 4 inb = 1 , nnb
          ybeam = nolev1+iul*stemlen+islope*xelsk(inb)/slfac
          ynote = nolev(iv,ipb(inb))
          smin = min(smin,iul*(ybeam-ynote))
4       continue
        if (smin .lt. stemmin) then
          deficit = stemmin-smin
          nolevo = nolev1
          nolev1 = ni(nolev1+iul*deficit)
        end if
      return
      end  
